//=============================================================================
///	Floating-point number
/**

Functions:
	+, -, *, /, ==, <, >, <=, >= (override)

	sqrt
	sin
	cos
	tan
	exp
	expt
	log
	asin
	acos
	atan
	atan2

	floor
	ceil

Constant:
	PI

*/
//=============================================================================

#include "mfpnum.h"
#include "sfpnum.h"
#include "sexp.h"
#include "ssym.h"
#include "senv.h"
#include <math.h>

#ifndef	M_PI
#define	M_PI		((SFPnum)3.14159265358979323846264338328)
#endif

static const char ERR_NUM_REQUIRED[] = "number required";


//=============================================================================
// subr

typedef	SFixnum (*FixnumOpFunc)(SFixnum, SFixnum);
typedef	SFPnum (*FPnumOpFunc)(SFPnum, SFPnum);
typedef	int (*FixnumPredFunc)(SFixnum, SFixnum);
typedef	int (*FPnumPredFunc)(SFPnum, SFPnum);

INLINE SFPnum S2FPNUM(SExp s)		{ return s.ptr->fpnum.val; }

SFPnum get_fpnum(SExp s) {
L_again:;
	switch (type_of(s)) {
	default:
		s = error(ERR_NUM_REQUIRED);
		goto L_again;
	case tFixnum:
		return (SFPnum)s2fixnum(s);
	case tFPnum:
		return S2FPNUM(s);
	}
}

static SExp fpnum_numop(SFPnum r, int narg, SExp args[], int i, SExp a, FPnumOpFunc fpop) {
	if (!nilp(a))	goto L_start_loop;
	for (; i<narg; ++i) {
		SFPnum f;
		a = args[i];
L_start_loop:;
		f = get_fpnum(a);
		r = fpop(r, f);
	}
	return gen_fpnum(r);
}

static SExp numop(int narg, SExp args[], FixnumOpFunc fixop, FPnumOpFunc fpop) {
	SFixnum r;
	SExp a;
	int i;

	a = args[0];
L_again0:;
	switch (type_of(a)) {
	default:
		a = error(ERR_NUM_REQUIRED);
		goto L_again0;
	case tFixnum:
		r = s2fixnum(a);
		break;
	case tFPnum:
		return fpnum_numop(S2FPNUM(a), narg, args, 1, nil, fpop);
	}

	for (i=1; i<narg; ++i) {
		a = args[i];
L_again:;
		switch (type_of(a)) {
		default:
			a = error(ERR_NUM_REQUIRED);
			goto L_again;
		case tFixnum:
			r = fixop(r, s2fixnum(a));
			break;
		case tFPnum:
			return fpnum_numop((SFPnum)r, narg, args, i, a, fpop);
		}
	}
	return fixnum2s(r);
}

static SExp numop1(SFixnum r, SExp a, FixnumOpFunc fixop, FPnumOpFunc fpop) {
L_again0:;
	switch (type_of(a)) {
	default:
		a = error(ERR_NUM_REQUIRED);
		goto L_again0;
	case tFixnum:
		return fixnum2s(fixop(r, s2fixnum(a)));
	case tFPnum:
		return gen_fpnum(fpop(r, S2FPNUM(a)));
	}
}


static SFixnum plus_fixop(SFixnum a, SFixnum b)		{ return a + b; }
static SFPnum plus_fpop(SFPnum a, SFPnum b)			{ return a + b; }
static SExp f_plus(int narg, SExp args[]) {
	if (narg == 0) {
		return fixnum2s(0);
	} else {
		return numop(narg, args, plus_fixop, plus_fpop);
	}
}


static SFixnum times_fixop(SFixnum a, SFixnum b)		{ return a * b; }
static SFPnum times_fpop(SFPnum a, SFPnum b)			{ return a * b; }
static SExp f_times(int narg, SExp args[]) {
	if (narg == 0) {
		return fixnum2s(1);
	} else {
		return numop(narg, args, times_fixop, times_fpop);
	}
}


static SFixnum difference_fixop(SFixnum a, SFixnum b)		{ return a - b; }
static SFPnum difference_fpop(SFPnum a, SFPnum b)			{ return a - b; }
static SExp f_difference(int narg, SExp args[]) {
	if (narg == 1) {
		return numop1((SFixnum)0, args[0], difference_fixop, difference_fpop);
	} else {
		return numop(narg, args, difference_fixop, difference_fpop);
	}
}


static SFixnum quotient_fixop(SFixnum a, SFixnum b)		{ return a / b; }
static SFPnum quotient_fpop(SFPnum a, SFPnum b)			{ return a / b; }
static SExp f_quotient(int narg, SExp args[]) {
	if (narg == 1) {
		return numop1((SFixnum)1, args[0], quotient_fixop, quotient_fpop);
	} else {
		return numop(narg, args, quotient_fixop, quotient_fpop);
	}
}





static SExp fpnum_cmpop(SFPnum r, int narg, SExp args[], int i, SExp a, FPnumPredFunc fpop) {
	if (!nilp(a))	goto L_start_loop;
	for (; i<narg; ++i) {
		SFPnum f;
		a = args[i];
L_start_loop:;
		f = get_fpnum(a);
		if (!fpop(r, f)) {
			return nil;
		}
		r = f;
	}
	return t;
}

static SExp cmpop(int narg, SExp args[], FixnumPredFunc fixop, FPnumPredFunc fpop) {
	SFixnum r;
	SExp a;
	int i;

	a = args[0];
L_again0:;
	switch (type_of(a)) {
	default:
		a = error(ERR_NUM_REQUIRED);
		goto L_again0;
	case tFixnum:
		r = s2fixnum(a);
		break;
	case tFPnum:
		return fpnum_cmpop(S2FPNUM(a), narg, args, 1, nil, fpop);
	}

	for (i=1; i<narg; ++i) {
		a = args[i];
L_again:;
		switch (type_of(a)) {
		default:
			a = error(ERR_NUM_REQUIRED);
			goto L_again;
		case tFixnum:
			{
				SFixnum f = s2fixnum(a);
				if (!fixop(r, f)) {
					return nil;
				}
				r = f;
			}
			break;
		case tFPnum:
			return fpnum_cmpop((SFPnum)r, narg, args, i, a, fpop);
		}
	}
	return t;
}




static int eq_fixop(SFixnum a, SFixnum b) { return a == b; }
static int eq_fpop(SFPnum a, SFPnum b) { return a == b; }
static SExp f_numeq(int narg, SExp args[]) {
	return cmpop(narg, args, eq_fixop, eq_fpop);
}

static int lt_fixop(SFixnum a, SFixnum b) { return a < b; }
static int lt_fpop(SFPnum a, SFPnum b) { return a < b; }
static SExp f_lt(int narg, SExp args[]) {
	return cmpop(narg, args, lt_fixop, lt_fpop);
}

static int gt_fixop(SFixnum a, SFixnum b) { return a > b; }
static int gt_fpop(SFPnum a, SFPnum b) { return a > b; }
static SExp f_gt(int narg, SExp args[]) {
	return cmpop(narg, args, gt_fixop, gt_fpop);
}

static int le_fixop(SFixnum a, SFixnum b) { return a <= b; }
static int le_fpop(SFPnum a, SFPnum b) { return a <= b; }
static SExp f_le(int narg, SExp args[]) {
	return cmpop(narg, args, le_fixop, le_fpop);
}

static int ge_fixop(SFixnum a, SFixnum b) { return a >= b; }
static int ge_fpop(SFPnum a, SFPnum b) { return a >= b; }
static SExp f_ge(int narg, SExp args[]) {
	return cmpop(narg, args, ge_fixop, ge_fpop);
}





INLINE SExp fp_func1(SFPnum (*f)(SFPnum), SExp s) {
	return gen_fpnum(f(get_fpnum(s)));
}
INLINE SExp fp_func2(SFPnum (*f)(SFPnum, SFPnum), SExp s1, SExp s2) {
	return gen_fpnum(f(get_fpnum(s1), get_fpnum(s2)));
}

static SExp f_sqrt(int narg, SExp args[]) {
	return fp_func1(sqrt, args[0]);
}

static SExp f_sin(int narg, SExp args[]) {
	return fp_func1(sin, args[0]);
}

static SExp f_cos(int narg, SExp args[]) {
	return fp_func1(cos, args[0]);
}

static SExp f_tan(int narg, SExp args[]) {
	return fp_func1(tan, args[0]);
}

static SExp f_exp(int narg, SExp args[]) {
	return fp_func1(exp, args[0]);
}

static SExp f_expt(int narg, SExp args[]) {
	return fp_func2(pow, args[0], args[1]);
}

static SExp f_log(int narg, SExp args[]) {
	return fp_func1(log, args[0]);
}

static SExp f_asin(int narg, SExp args[]) {
	return fp_func1(asin, args[0]);
}

static SExp f_acos(int narg, SExp args[]) {
	return fp_func1(acos, args[0]);
}

static SExp f_atan(int narg, SExp args[]) {
	return fp_func1(atan, args[0]);
}

static SExp f_atan2(int narg, SExp args[]) {
	return fp_func2(atan2, args[0], args[1]);
}

static SExp f_floor(int narg, SExp args[]) {
	return fp_func1(floor, args[0]);
}

static SExp f_ceil(int narg, SExp args[]) {
	return fp_func1(ceil, args[0]);
}


//=============================================================================

void define_fpnum_module(void) {
	struct {
		const char* name;
		SubrType cfunc;
		int minargnum, maxargnum;
	} subr_tbl[] = {
		{	"+",					f_plus,					0,	-1,	},
		{	"*",					f_times,				0,	-1,	},
		{	"-",					f_difference,			1,	-1,	},
		{	"/",					f_quotient,				1,	-1,	},
		{	"==",					f_numeq,				2,	-1,	},
		{	"<",					f_lt,					2,	-1,	},
		{	">",					f_gt,					2,	-1,	},
		{	"<=",					f_le,					2,	-1,	},
		{	">=",					f_ge,					2,	-1,	},

		{	"sqrt",					f_sqrt,					1,	1,	},
		{	"sin",					f_sin,					1,	1,	},
		{	"cos",					f_cos,					1,	1,	},
		{	"tan",					f_tan,					1,	1,	},
		{	"exp",					f_exp,					1,	1,	},
		{	"expt",					f_expt,					2,	2,	},
		{	"log",					f_log,					1,	1,	},
		{	"asin",					f_asin,					1,	1,	},
		{	"acos",					f_acos,					1,	1,	},
		{	"atan",					f_atan,					1,	1,	},
		{	"atan2",				f_atan2,				2,	2,	},

		{	"floor",				f_floor,				1,	1,	},
		{	"ceil",					f_ceil,					1,	1,	},
	};
	int i;
	for (i=0; i<sizeof(subr_tbl)/sizeof(*subr_tbl); ++i) {
		SExp subr = gen_subr(subr_tbl[i].cfunc, subr_tbl[i].name, subr_tbl[i].minargnum, subr_tbl[i].maxargnum);
		SExp sym = intern(subr_tbl[i].name);
		setq(sym, subr);
	}

	defconst(intern("PI"), gen_fpnum(M_PI));
}

